home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 27 / CU Amiga Magazine's Super CD-ROM 27 (1998)(EMAP Images)(GB)[!][issue 1998-10].iso / CUCD / Programming / JForth / Extras / SysGen / long-references < prev    next >
Encoding:
Text File  |  1987-03-12  |  3.7 KB  |  95 lines
  1.  
  2. \ ************************ Long-References ***************************
  3.  
  4. \ when a long reference is compiled...
  5. \ 1. A 'jsr.l  abs' is compiled, along with the ABSOLUTE address of the
  6. \    word being called.
  7. \ 2. The long reference must be recorded in the memory block returned by
  8. \    'RelocsAdr'. This block is included in saved executable images, and used
  9. \    by the dynamic loader to resolve them.
  10. \ 3. It is included again in the saved image to be loaded as a data area,
  11. \    the loader is setup to poke its absolute address into a user var
  12. \    called 'ABSRELOCS'.  The Pushreloc program can initialize the addresses
  13. \    the first time thru; i.e. ...
  14. \    a. IF #RELOCS = 0...allocate a block, put its relative adr in RELOCS
  15. \       and the abs addr in ABSADDR, inc #RELOCS to 1.
  16. \    b. IF #RELOCS \= 0, check if RELOCS is equal to 'ABSRELOCS @ >REL'
  17. \       if so, all ok, just add the new reference.  If not, initialize RELOCS
  18. \       to point to the correct place, then continue.
  19.  
  20. \ NOW IN KERNAL -> user Relocs     ( rel addr of array for reloc storage )
  21. user AbsRelocs  ( abs addr of array for reloc storage )
  22. user #Relocs    ( number of relocs compiled in the system )
  23.  
  24. : RelocsAdr  ( -- addr , make sure Relocs is pointing to a valid place )
  25.   relocs @ -dup 0=
  26.   IF   ( ...no block is allocated OR Relocs hasn't been initialized... )
  27.        AbsRelocs @ -dup 0=
  28.        IF   ( ...no block is allocated )
  29.             0 1024 XAllocblk   -dup 0=
  30.             IF   cr ." can't allocate relocation storage block!"   quit
  31.             THEN ( ...block was allocated ok )
  32.        ELSE ( block existed at boot, was relocated at ABSRelocs, update Relocs )
  33.             3 cells + >rel
  34.        THEN   dup relocs !  dup relocs +boots !
  35.   THEN ( address-of-block -- )
  36. ;
  37.  
  38. : ?forgotten  ( -- , update references if FORGET has invalidated some )
  39. ( note: have FORGET erase from here to stack! )
  40.   #relocs @
  41.   IF   RelocsAdr dup  freebyte -dup
  42.        IF   ( ...relocs allocated and entries exist )  ( adr freebyte -- )
  43.             cell- + @ dup
  44.             here < 0=              \ is it above where we're now at?
  45.             swap 2- w@ $ 4eb9 - or   \ OR is there NOT a 'jsr' there?
  46.             IF   ( ...last reloc is above here, adjust till below )
  47.                  relocs @  dup freebyte
  48.                  dup >r  cell- + r> swap   ( freebyte adr-of-last-item-- )
  49.                  BEGIN   dup @ here < >r   over 0= r> or not
  50.                  WHILE   cell- swap cell- swap  -1 #relocs +!
  51.                  REPEAT  drop  relocs @ freebytea !
  52.             THEN
  53.        ELSE drop
  54.        THEN
  55.   THEN
  56. ;
  57.  
  58. : PushReloc  ( relative-address-needing-relocation -- )
  59.   ?forgotten
  60.   RelocsAdr ( address-of-block -- )
  61.   ( ...check if block is full )
  62.   dup freebyte  over sizemem  < 0=   ( adr flag -- )
  63.   IF   ( the current memory block is full, allocate a bigger one, copy to it )
  64.        \ version 1.201 ... changed Allocblock to XAllocBlk, next line...
  65.        dup sizemem  1024 +   0 swap xallocblk   ( oldblk newblk -- )
  66.        over freebyte over freebytea !          ( oldblk newblk -- )
  67.        over freebyte  0
  68.        DO   over i + @   over i + !   cell
  69.       +LOOP swap absrelocs @ 3 cells +  >rel  over -
  70.        IF   freeblock  ( free the old )
  71.        ELSE drop ( don't free what I didn't allocate )
  72.        THEN ( newblk -- )
  73.        dup relocs !  dup relocs +boots !
  74.   THEN 
  75.   push    1 #relocs +!
  76. ; ' pushreloc 'pushreloc !
  77.  
  78.  
  79. : (LongCFA,)   ( pfa -- )
  80.   $ 4eb9  w,        \ the opcode for the3 'JSR.L'
  81.   here PushReloc    \ relative address of the reloc point
  82.   >abs ,            \ comma in the real runtime address
  83. ;
  84.  
  85. ' (LongCFA,) is longcfa,
  86.  
  87. : BYE    ( -- )
  88.   relocs @  -dup
  89.   IF   absrelocs @ 3 cells +  >rel  over -
  90.        IF   Xfreeblk  ( free the old )
  91.        ELSE drop ( don't free what I didn't allocate )
  92.        THEN
  93.   then bye
  94. ;
  95.